home *** CD-ROM | disk | FTP | other *** search
/ Aminet 2 / Aminet AMIGA CDROM (1994)(Walnut Creek)[Feb 1994][W.O. 44790-1].iso / Aminet / util / gnu / emacs_src.lha / emacs-18.58 / lisp / x-mouse.el < prev    next >
Lisp/Scheme  |  1992-02-21  |  11KB  |  292 lines
  1. ;; Mouse support for X window system.
  2. ;; Copyright (C) 1985, 1987 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of GNU Emacs.
  5.  
  6. ;; GNU Emacs is free software; you can redistribute it and/or modify
  7. ;; it under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation; either version 1, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; GNU Emacs is distributed in the hope that it will be useful,
  12. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;; GNU General Public License for more details.
  15.  
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  18. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20.  
  21. (provide 'x-mouse)
  22.  
  23. (defconst x-button-right (char-to-string 0))
  24. (defconst x-button-middle (char-to-string 1))
  25. (defconst x-button-left (char-to-string 2))
  26.  
  27. (defconst x-button-right-up (char-to-string 4))
  28. (defconst x-button-middle-up (char-to-string 5))
  29. (defconst x-button-left-up (char-to-string 6))
  30.  
  31. (defconst x-button-s-right (char-to-string 16))
  32. (defconst x-button-s-middle (char-to-string 17))
  33. (defconst x-button-s-left (char-to-string 18))
  34.  
  35. (defconst x-button-s-right-up (char-to-string 20))
  36. (defconst x-button-s-middle-up (char-to-string 21))
  37. (defconst x-button-s-left-up (char-to-string 22))
  38.  
  39. (defconst x-button-m-right (char-to-string 32))
  40. (defconst x-button-m-middle (char-to-string 33))
  41. (defconst x-button-m-left (char-to-string 34))
  42.  
  43. (defconst x-button-m-right-up (char-to-string 36))
  44. (defconst x-button-m-middle-up (char-to-string 37))
  45. (defconst x-button-m-left-up (char-to-string 38))
  46.  
  47. (defconst x-button-c-right (char-to-string 64))
  48. (defconst x-button-c-middle (char-to-string 65))
  49. (defconst x-button-c-left (char-to-string 66))
  50.  
  51. (defconst x-button-c-right-up (char-to-string 68))
  52. (defconst x-button-c-middle-up (char-to-string 69))
  53. (defconst x-button-c-left-up (char-to-string 70))
  54.  
  55. (defconst x-button-m-s-right (char-to-string 48))
  56. (defconst x-button-m-s-middle (char-to-string 49))
  57. (defconst x-button-m-s-left (char-to-string 50))
  58.  
  59. (defconst x-button-m-s-right-up (char-to-string 52))
  60. (defconst x-button-m-s-middle-up (char-to-string 53))
  61. (defconst x-button-m-s-left-up (char-to-string 54))
  62.  
  63. (defconst x-button-c-s-right (char-to-string 80))
  64. (defconst x-button-c-s-middle (char-to-string 81))
  65. (defconst x-button-c-s-left (char-to-string 82))
  66.  
  67. (defconst x-button-c-s-right-up (char-to-string 84))
  68. (defconst x-button-c-s-middle-up (char-to-string 85))
  69. (defconst x-button-c-s-left-up (char-to-string 86))
  70.  
  71. (defconst x-button-c-m-right (char-to-string 96))
  72. (defconst x-button-c-m-middle (char-to-string 97))
  73. (defconst x-button-c-m-left (char-to-string 98))
  74.  
  75. (defconst x-button-c-m-right-up (char-to-string 100))
  76. (defconst x-button-c-m-middle-up (char-to-string 101))
  77. (defconst x-button-c-m-left-up (char-to-string 102))
  78.  
  79. (defconst x-button-c-m-s-right (char-to-string 112))
  80. (defconst x-button-c-m-s-middle (char-to-string 113))
  81. (defconst x-button-c-m-s-left (char-to-string 114))
  82.  
  83. (defconst x-button-c-m-s-right-up (char-to-string 116))
  84. (defconst x-button-c-m-s-middle-up (char-to-string 117))
  85. (defconst x-button-c-m-s-left-up (char-to-string 118))
  86.  
  87. (defvar x-process-mouse-hook nil
  88.   "Hook to run after each mouse event is processed.  Should take two
  89. arguments; the first being a list (XPOS YPOS) corresponding to character
  90. offset from top left of screen and the second being a specifier for the
  91. buttons/keys.
  92.  
  93. This will normally be set on a per-buffer basis.")
  94.  
  95. (defun x-flush-mouse-queue () 
  96.   "Process all queued mouse events."
  97.   ;; A mouse event causes a special character sequence to be given
  98.   ;; as keyboard input.  That runs this function, which process all
  99.   ;; queued mouse events and returns.
  100.   (interactive)
  101.   (while (> (x-mouse-events) 0)
  102.     (x-proc-mouse-event)
  103.     (and (boundp 'x-process-mouse-hook)
  104.      (symbol-value 'x-process-mouse-hook)
  105.      (funcall x-process-mouse-hook x-mouse-pos x-mouse-item))))
  106.  
  107. (define-key global-map "\C-c\C-m" 'x-flush-mouse-queue)
  108. (define-key global-map "\C-x\C-@" 'x-flush-mouse-queue)
  109.  
  110. (defun x-mouse-select (arg)
  111.   "Select Emacs window the mouse is on."
  112.   (let ((start-w (selected-window))
  113.     (done nil)
  114.     (w (selected-window))
  115.     (rel-coordinate nil))
  116.     (while (and (not done)
  117.         (null (setq rel-coordinate
  118.                 (coordinates-in-window-p arg w))))
  119.       (setq w (next-window w))
  120.       (if (eq w start-w)
  121.       (setq done t)))
  122.     (select-window w)
  123.     rel-coordinate))
  124.  
  125. (defun x-mouse-keep-one-window (arg)
  126.   "Select Emacs window mouse is on, then kill all other Emacs windows."
  127.   (if (x-mouse-select arg)
  128.       (delete-other-windows)))
  129.  
  130. (defun x-mouse-select-and-split (arg)
  131.   "Select Emacs window mouse is on, then split it vertically in half."
  132.   (if (x-mouse-select arg)
  133.       (split-window-vertically nil)))
  134.  
  135. (defun x-mouse-set-point (arg)
  136.   "Select Emacs window mouse is on, and move point to mouse position."
  137.   (let* ((relative-coordinate (x-mouse-select arg))
  138.      margin-column
  139.      (rel-x (car relative-coordinate))
  140.      (rel-y (car (cdr relative-coordinate))))
  141.     (if relative-coordinate
  142.     (let ((prompt-width (if (eq (selected-window) (minibuffer-window))
  143.                 minibuffer-prompt-width 0)))
  144.       (move-to-window-line rel-y)
  145.       (setq margin-column
  146.         (if (or truncate-lines (> (window-hscroll) 0))
  147.             (current-column)
  148.           ;; If we are using line continuation,
  149.           ;; compensate if first character on a continuation line
  150.           ;; does not start precisely at the margin.
  151.           (- (current-column)
  152.              (% (current-column) (1- (window-width))))))
  153.       (move-to-column (+ rel-x (1- (max 1 (window-hscroll)))
  154.                  (if (= (point) 1)
  155.                  (- prompt-width) 0)
  156.                  margin-column))))))
  157.  
  158. (defun x-mouse-set-mark (arg)
  159.   "Select Emacs window mouse is on, and set mark at mouse position.
  160. Display cursor at that position for a second."
  161.   (if (x-mouse-select arg)
  162.       (let ((point-save (point)))
  163.     (unwind-protect
  164.         (progn (x-mouse-set-point arg)
  165.            (push-mark nil t)
  166.            (sit-for 1))
  167.       (goto-char point-save)))))
  168.  
  169. (defun x-cut-text (arg &optional kill)
  170.   "Copy text between point and mouse position into window system cut buffer.
  171. Save in Emacs kill ring also."
  172.   (if (coordinates-in-window-p arg (selected-window))
  173.       (save-excursion
  174.     (let ((opoint (point))
  175.           beg end)
  176.       (x-mouse-set-point arg)
  177.       (setq beg (min opoint (point))
  178.         end (max opoint (point)))
  179.       (x-store-cut-buffer (buffer-substring beg end))
  180.       (copy-region-as-kill beg end)
  181.       (if kill (delete-region beg end))))
  182.     (message "Mouse not in selected window")))
  183.  
  184. (defun x-paste-text (arg)
  185.   "Move point to mouse position and insert window system cut buffer contents."
  186.   (x-mouse-set-point arg)
  187.   (insert (x-get-cut-buffer)))
  188.  
  189. (defun x-cut-and-wipe-text (arg)
  190.   "Kill text between point and mouse; also copy to window system cut buffer."
  191.   (x-cut-text arg t))
  192.  
  193. (defun x-mouse-ignore (arg)
  194.   "Don't do anything.")
  195.  
  196. (defun x-buffer-menu (arg)
  197.   "Pop up a menu of buffers for selection with the mouse."
  198.   (let ((menu
  199.      (list "Buffer Menu"
  200.            (cons "Select Buffer"
  201.              (let ((tail (buffer-list))
  202.                head)
  203.                (while tail
  204.              (let ((elt (car tail)))
  205.                (if (not (string-match "^ "
  206.                           (buffer-name elt)))
  207.                    (setq head (cons
  208.                        (cons
  209.                         (format
  210.                          "%14s   %s"
  211.                          (buffer-name elt)
  212.                          (or (buffer-file-name elt) ""))
  213.                         elt)
  214.                        head))))
  215.              (setq tail (cdr tail)))
  216.                (reverse head))))))
  217.     (switch-to-buffer (or (x-popup-menu arg menu) (current-buffer)))))
  218.  
  219. (defun x-help (arg)
  220.   "Enter a menu-based help system."
  221.   (let ((selection
  222.      (x-popup-menu
  223.       arg
  224.       '("Help" ("Is there a command that..."
  225.             ("Command apropos" . command-apropos)
  226.             ("Apropos" . apropos))
  227.            ("Key Commands <==> Functions"
  228.             ("List all keystroke commands" . describe-bindings)
  229.             ("Describe key briefly" . describe-key-briefly)
  230.             ("Describe key verbose" . describe-key)
  231.             ("Describe Lisp function" . describe-function)
  232.             ("Where is this command" . where-is))
  233.            ("Manual and tutorial"
  234.             ("Info system" . info)
  235.             ("Invoke Emacs tutorial" . help-with-tutorial))
  236.            ("Odds and ends"
  237.             ("Last 100 Keystrokes" . view-lossage)
  238.             ("Describe syntax table" . describe-syntax))
  239.            ("Modes"
  240.             ("Describe current major mode" . describe-mode)
  241.             ("List all keystroke commands" . describe-bindings))
  242.            ("Administrivia"
  243.             ("View Emacs news" . view-emacs-news)
  244.             ("View the GNU Emacs license" . describe-copying)
  245.             ("Describe distribution" . describe-distribution)
  246.             ("Describe (non)warranty" . describe-no-warranty))))))
  247.     (and selection (call-interactively selection))))
  248.  
  249. ; Prevent beeps on button-up.  If the button isn't bound to anything, it
  250. ; will beep on button-down.
  251. (define-key mouse-map x-button-right-up 'x-mouse-ignore)
  252. (define-key mouse-map x-button-middle-up 'x-mouse-ignore)
  253. (define-key mouse-map x-button-left-up 'x-mouse-ignore)
  254. (define-key mouse-map x-button-s-right-up 'x-mouse-ignore)
  255. (define-key mouse-map x-button-s-middle-up 'x-mouse-ignore)
  256. (define-key mouse-map x-button-s-left-up 'x-mouse-ignore)
  257. (define-key mouse-map x-button-m-right-up 'x-mouse-ignore)
  258. (define-key mouse-map x-button-m-middle-up 'x-mouse-ignore)
  259. (define-key mouse-map x-button-m-left-up 'x-mouse-ignore)
  260. (define-key mouse-map x-button-c-right-up 'x-mouse-ignore)
  261. (define-key mouse-map x-button-c-middle-up 'x-mouse-ignore)
  262. (define-key mouse-map x-button-c-left-up 'x-mouse-ignore)
  263. (define-key mouse-map x-button-m-s-right-up 'x-mouse-ignore)
  264. (define-key mouse-map x-button-m-s-middle-up 'x-mouse-ignore)
  265. (define-key mouse-map x-button-m-s-left-up 'x-mouse-ignore)
  266. (define-key mouse-map x-button-c-s-right-up 'x-mouse-ignore)
  267. (define-key mouse-map x-button-c-s-middle-up 'x-mouse-ignore)
  268. (define-key mouse-map x-button-c-s-left-up 'x-mouse-ignore)
  269. (define-key mouse-map x-button-c-m-right-up 'x-mouse-ignore)
  270. (define-key mouse-map x-button-c-m-middle-up 'x-mouse-ignore)
  271. (define-key mouse-map x-button-c-m-left-up 'x-mouse-ignore)
  272. (define-key mouse-map x-button-c-m-s-right-up 'x-mouse-ignore)
  273. (define-key mouse-map x-button-c-m-s-middle-up 'x-mouse-ignore)
  274. (define-key mouse-map x-button-c-m-s-left-up 'x-mouse-ignore)
  275.  
  276. (define-key mouse-map x-button-c-s-left 'x-buffer-menu)
  277. (define-key mouse-map x-button-c-s-middle 'x-help)
  278. (define-key mouse-map x-button-c-s-right 'x-mouse-keep-one-window)
  279. (define-key mouse-map x-button-s-middle 'x-cut-text)
  280. (define-key mouse-map x-button-s-right 'x-paste-text)
  281. (define-key mouse-map x-button-c-middle 'x-cut-and-wipe-text)
  282. (define-key mouse-map x-button-c-right 'x-mouse-select-and-split)
  283.  
  284. (if (= window-system-version 10)
  285.     (progn
  286.       (define-key mouse-map x-button-right 'x-mouse-select)
  287.       (define-key mouse-map x-button-left 'x-mouse-set-mark)
  288.       (define-key mouse-map x-button-middle 'x-mouse-set-point))
  289.   (define-key mouse-map x-button-right 'x-cut-text)
  290.   (define-key mouse-map x-button-left 'x-mouse-set-point)
  291.   (define-key mouse-map x-button-middle 'x-paste-text))
  292.